home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / pasutils.arc / PASUTI.PAS
Encoding:
Pascal/Delphi Source File  |  1985-09-23  |  6.4 KB  |  245 lines
  1. (*************************************************************************)
  2. (* A set of utilities for TURBO-Pascal on the IBM-PC and compatibles     *)
  3. (* for file-appending, checking Key-Locks and display-type.              *)
  4. (* Included ist wait_for_any_key, a procedure which responds to ANY key. *)
  5. (* Uploaded by RMI Nachrichtentechnik GmbH, Aachen, West Germany         *)
  6. (* Author      W. Siebeck, CIS 72446,415                                 *)
  7. (*************************************************************************)
  8.  
  9.  
  10. Type
  11. line         = string[255];
  12. byte_type    = file of byte;
  13.  
  14. const
  15. eof_mark : byte = $1A;
  16.  
  17. Offset       : integer = 3680;
  18. (* Offset is needed in the lock_status procedure. It should be set to     *)
  19. (* 3680 to get the lock-display in line 25 of the screen                  *)
  20.  
  21. var
  22. ScreenBase         : integer;
  23. demochar           : char;
  24.  
  25.  
  26. Procedure DetermineDisplay;
  27. { Set ScreenBase to $B000 or $B800, depending on which display is in use. }
  28. { This Version adapted from the IBM-BASIC-Manual                          }
  29. Var
  30.     T: Byte;
  31.  
  32. Begin
  33.     t := (mem[0000:$0410] and $0030);
  34.     if (t=$0030) then ScreenBase := $B000
  35.                  else ScreenBase := $B800
  36. End;
  37.  
  38.  
  39. (* Equivalent for the BASIC LEFT$(A$,M)  *)
  40. (* Returns the left i1 characters of st1 *)
  41.  
  42. function leftstr (st1: line; i1: byte): line;
  43. var
  44. tempst : line;
  45. n      : byte;
  46.  
  47. begin
  48.     tempst := '';
  49.     n:=length (st1);
  50.     if (n > i1) then tempst := copy (st1,1,i1)
  51.     else tempst := st1;
  52.     leftstr := tempst;
  53. end;
  54.  
  55. (* Equivalent for the BASIC RIGHT$(A$,M)  *)
  56. (* Returns the right i1 characters of st1 *)
  57.  
  58. function rightstr (st1: line; i1: byte): line;
  59. var
  60. tempst : line;
  61. n      : byte;
  62.  
  63. begin
  64.     n := length (st1);
  65.     if (n <= i1) then tempst := st1
  66.     else tempst := copy (st1,n-i1+1,i1);
  67.     rightstr := tempst;
  68. end; (* rightstr *)
  69.  
  70. (* Checks, if File 'filnam' exists on disk *)
  71. function exist (filnam: line): boolean;
  72.  
  73. var
  74. fil:     file;
  75. bool:    boolean;
  76. begin
  77.     assign (fil,filnam);
  78.     {$I-} reset (fil) {$I+};
  79.     bool := (ioresult=0);
  80.     if bool then close (fil);
  81.     exist := bool;
  82. end; (* exist *)
  83.  
  84. (* Write a line of text to a byte_type file *)
  85. procedure write_text_to_file (var fil: byte_type;
  86.                                 zeile: line;
  87.                                 var result: integer);
  88.  
  89. var
  90. st1,character : byte;
  91.  
  92. begin
  93.      st1 := 1;
  94.      result := 0;
  95.      while ((st1 <= length (zeile)) and (result = 0)) do
  96.      begin
  97.           character := ord (copy (zeile,st1,1));
  98.           {$I-} write (fil,character); {$I+}
  99.           result := ioresult;
  100.           st1 := succ (st1)
  101.      end
  102. end; (* schreib *)
  103.  
  104. (* Open a file for APPEND *)
  105. (* To close this file, please use close_append to keep the file *)
  106. (* WordStar-compatible. Close_append writes a ^Z at the EOF!    *)
  107.  
  108. procedure opena (var fil: byte_type; filename: line; var error: integer);
  109.  
  110. var
  111. position : real;
  112. test     : byte;
  113. search   : boolean;
  114.  
  115. begin
  116.     if exist (filename) then
  117.     begin
  118.         assign (fil, filename);
  119.         {$I-} reset (fil) {$I+};
  120.         error := ioresult;
  121.         if (error = 0) then
  122.         begin
  123.             LongSeek (fil,LongFileSize(fil));
  124.             for test := 1 to 5 do write (fil,eof_mark); { make sure eof is marked }
  125.             position := LongFilePos(fil) - 2.0;
  126.             repeat
  127.                 position := position - 1.0;
  128.                 LongSeek (fil,position);
  129.                 read (fil,test);
  130.             until ((test <> eof_mark) or (position < 1.0));
  131.             if (position < 1.0) then LongSeek (fil,position)
  132.         end
  133.     end
  134.     else
  135.     begin
  136.         assign (fil, filename);
  137.         {$I-} rewrite (fil) {$I+};
  138.         error := ioresult
  139.     end
  140.  
  141. end; (* opena *)
  142.  
  143. (* close APPEND-File *)
  144. procedure close_append (var fil: byte_type);
  145.  
  146. var
  147. murks : integer;
  148.  
  149. begin
  150.  
  151.     {$I-}
  152.     write (fil,eof_mark);
  153.     murks := ioresult;
  154.     close (fil);
  155.     murks := ioresult;
  156.     {$I+}
  157.  
  158. end; (* close_append *)
  159.  
  160. (* This procedure responds to ANY key ! *)
  161. procedure wait_for_any_key;
  162.  
  163. var
  164. status : byte;
  165.  
  166. begin
  167.     delay (1000);
  168.     status := (mem[$0000:$0417] and 176); { save state of NUM-CAPS-INS-Lock }
  169.     mem[$0000:$0417] := 32;               { now force NUM-Lock for 5-Key !  }
  170.     repeat until (keypressed or (mem[$0000:$0417]<>32));
  171.     mem[$0000:$0417] := status;           { restore old Locks               }
  172.     mem[$0000:1050] := mem[$0000:1052];   { empty keyboard-buffer           }
  173. end; (* wait_for_any_key *)
  174.  
  175. (* This procedure displays the state of INS-CAPS-NUM-Locks and Shift-keys   *)
  176. (* in the lower right corner of the screen                                  *)
  177. (* Make sure to WINDOW-protect the last line !                              *)
  178. procedure lock_status;
  179.  
  180. function ins_lock : boolean;
  181.  
  182. begin
  183.     ins_lock := ((mem[0000:$417] and 128) <> 0);
  184. end; (* ins_lock *)
  185.  
  186. function num_lock : boolean;
  187.  
  188. begin
  189.     num_lock := ((mem[0000:$417] and 32) <> 0);
  190. end; (* num_lock *)
  191.  
  192. function caps_lock : boolean;
  193.  
  194. begin
  195.     caps_lock := ((mem[0000:$417] and 64) <> 0);
  196. end; (* caps_lock *)
  197.  
  198. function shift : boolean;
  199.  
  200. begin
  201.     shift := ((mem[0000:$417] and 3) <> 0);
  202. end; (* shift *)
  203.  
  204. begin
  205.  
  206.     if num_lock  then mem[ScreenBase:Offset + 312] := ord('N')
  207.                  else mem[ScreenBase:Offset + 312] := 32;
  208.  
  209.     if ins_lock  then mem[ScreenBase:Offset + 314] := ord('I')
  210.                  else mem[ScreenBase:Offset + 314] := 32;
  211.  
  212.     if caps_lock then mem[ScreenBase:Offset + 316] := ord('C')
  213.                  else mem[ScreenBase:Offset + 316] := 32;
  214.  
  215.     if shift     then mem[ScreenBase:Offset + 318] := ord('S')
  216.                  else mem[ScreenBase:Offset + 318] := 32;
  217.  
  218. end; (* lock_status *)
  219.  
  220. begin (* DEMO *)
  221.  
  222.     DetermineDisplay;
  223.     write ('You have a ');
  224.     if (ScreenBase = $B800) then write ('Colour')
  225.     else write ('Monochrome');
  226.     writeln ('-Display installed.');
  227.     writeln;
  228.     demochar := 'A';
  229.     writeln ('Try the locks, hit <SPACE> to continue ...');
  230.  
  231.     repeat
  232.         lock_status;
  233.         if keypressed then read (kbd, demochar);
  234.     until (demochar = ' ');
  235.  
  236.     ClrScr;
  237.     writeln ('Now hit any key to exit ...');
  238.  
  239.     wait_for_any_key;
  240.     sound (1000);
  241.     delay (1000);
  242.     nosound;
  243.  
  244. end. (* of DEMO *)
  245.